perm filename NSTRUC.LSP[NEW,LSP] blob
sn#363731 filedate 1978-07-05 generic text, type T, neo UTF8
;; New DEFSTRUCT. ALAN & DLW 12/11/77 -*-LISP-*-
;; CAUTION! This file must be compilable both by NCOMPLR and by QMOD; be quite
;; careful not to use anything which is dependent on one or the other Lisp dialect.
;; Documentation is in LMDOC;NDEFS >.
;; This file is LISPM2;NSTRUC >.
(DECLARE (COND ((= 1←24. 0))
((NULL (MEMQ 'NEWIO (STATUS FEATURES)))
(BREAK 'YOU-HAVE-TO-COMPILE-THIS-WITH-QCOMPL T))
((NULL (GET 'IF-FOR-MACLISP 'MACRO))
(LOAD '(MACROS > DSK LISPM))
(LOAD '(DEFMAC FASL DSK LISPM2))
(LOAD '(LMMAC > DSK LISPM2))
(MACROS T)))) ;SEND OVER THE REST OF THE MACROS IN THIS FILE
;; This still needs some more hair, for optimization of the simple cases of the
;; constructor macros.
(DEFMACRO DEFSTRUCT-PUTPROP (SYM VAL IND)
`(PROGN
(PUSH `(PUTPROP ',,SYM ',,VAL ',,IND) RETURNS)
(PUTPROP ,SYM ,VAL ,IND)))
(DEFMACRO DEFSTRUCT ((NAME . OPTIONS) . ITEMS)
(DEFSTRUCT-1 NAME OPTIONS ITEMS))
;; Returns a list of the form (PROGN 'COMPILE ...)
(DEFUN DEFSTRUCT-1 (NAME OPTIONS ITEMS)
(LET ((TYPE NIL) ;ARRAY, ARRAY-LEADER, or LIST.
(GROUPED-P NIL) ;NIL or T
(SIZE-SYMBOL NIL)
(SIZE-MACRO NIL)
(CONSTRUCTOR T) ;NIL for none at all, T for generated name, else name.
(NAMED-STRUCTURE NIL) ;The named-structure-symbol, NIL if none.
(DEFAULT-POINTER NIL)
(INCLUDE NIL) ;Name of DEFSTRUCT to include.
(OFFSET 0) ;Number of reserved words at beginning.
(TEM NIL) ;Random temporary.
(SIZE NIL) ;Size of this DEFSTRUCT.
(RETURNS NIL) ;The list which we return.
(ITEM-LIST NIL) ;A list of names of access macros.
(INIT-LIST NIL) ;The initialization for each.
(CONSTRUCTOR-ARRAY-OP NIL) ;MAKE-ARRAY-DEFAULT parameter.
(CONSTRUCTOR-TIMES-OP NIL) ;GROUPED-ARRAY parameter.
)
(PUSH `',NAME RETURNS)
(DO ((OPL OPTIONS (CDR OPL))
(OP)
(OPARGS)
(OPSOFAR NIL (CONS OP OPSOFAR)))
((NULL OPL))
(SETQ OP (CAR OPL))
(COND ((EQ (TYPEP OP) 'LIST)
(SETQ OPARGS (CDR OP) OP (CAR OP)))
(T (SETQ OPARGS NIL)))
(AND (MEMQ OP OPSOFAR)
(ERROR '|This optional was given more than once -- DEFSTRUCT| OPTIONS))
(SELECTQ OP
((ARRAY ARRAY-LEADER LIST)
(AND TYPE (ERROR '|The type was given more than once -- DEFSTRUCT| OPTIONS))
(SETQ TYPE OP))
(GROUPED-ARRAY
(SETQ CONSTRUCTOR-TIMES-OP (COND ((NULL OPARGS) 1)
(T (CAR OPARGS))))
(SETQ GROUPED-P T))
(TIMES
(SETQ CONSTRUCTOR-TIMES-OP (FIRST OPARGS)))
(MAKE-ARRAY
(SETQ CONSTRUCTOR-ARRAY-OP (FIRST OPARGS)))
(SIZE
(SETQ SIZE-SYMBOL (FIRST OPARGS)))
(SIZE-MACRO
(SETQ SIZE-MACRO (FIRST OPARGS)))
(CONSTRUCTOR
(SETQ CONSTRUCTOR (FIRST OPARGS)))
(NAMED-STRUCTURE
(SETQ NAMED-STRUCTURE
(COND ((NULL OPARGS) NAME)
(T (FIRST OPARGS)))))
(DEFAULT-POINTER
(SETQ DEFAULT-POINTER (FIRST OPARGS)))
(INCLUDE
(SETQ INCLUDE (FIRST OPARGS)))
(OTHERWISE
(ERROR '|Unrecognized option -- DEFSTRUCT| OP))))
(OR TYPE (SETQ TYPE 'ARRAY))
(AND (EQ CONSTRUCTOR T)
(SETQ CONSTRUCTOR (IMPLODE (APPEND '(M A K E -) (EXPLODE NAME)))))
;Drops through.
;Drops in.
;Done parsing the options, now do some random hacking and error checking.
(AND (EQ TYPE 'LIST) NAMED-STRUCTURE
(ERROR '| A list cannot be a named structure -- DEFSTRUCT| OPTIONS))
(COND (GROUPED-P
(AND NAMED-STRUCTURE
(ERROR '|A grouped-array cannot be a named-structure -- DEFSTRUCT| OPTIONS))
(OR (EQ TYPE 'ARRAY)
(ERROR '|A grouped-array must be an array -- DEFSTRUCT| TYPE))))
(DEFSTRUCT-PUTPROP NAME TYPE 'DEFSTRUCT-TYPE)
(AND NAMED-STRUCTURE (DEFSTRUCT-PUTPROP NAME T 'DEFSTRUCT-NAMED-P))
(AND GROUPED-P (DEFSTRUCT-PUTPROP NAME T 'DEFSTRUCT-GROUPED-P))
(COND (INCLUDE
(OR (NUMBERP (SETQ TEM (GET INCLUDE 'DEFSTRUCT-SIZE)))
(ERROR '|The included DEFSTRUCT has not yet been defined -- DEFSTRUCT| INCLUDE))
(COND
((AND NAMED-STRUCTURE
(NULL (GET INCLUDE 'DEFSTRUCT-NAMED-P)))
(ERROR '|A named-structure may not include a non-named-structure -- DEFSTRUCT|
NAME))
((AND (NULL NAMED-STRUCTURE)
(GET INCLUDE 'DEFSTRUCT-NAMED-P))
(ERROR '|A non-named-structure may not include a named-structure -- DEFSTRUCT|
NAME))
((NEQ (GET INCLUDE 'DEFSTRUCT-TYPE) TYPE)
(ERROR '|INCLUDE types did not match -- DEFSTRUCT| TYPE))
((GET INCLUDE 'DEFSTRUCT-GROUPED-P)
(ERROR '|A structure may not include a grouped-array -- DEFSTRUCT| NAME))
(GROUPED-P
(ERROR '|A grouped array may not include another structure -- DEFSTRUCT| NAME)))
(SETQ OFFSET (+ OFFSET TEM))))
;Now we have OFFSET and can get SIZE.
(SETQ SIZE (+ OFFSET (LENGTH ITEMS)))
(DEFSTRUCT-PUTPROP NAME SIZE 'DEFSTRUCT-SIZE)
(AND SIZE-SYMBOL
(PUSH `(SETQ ,SIZE-SYMBOL ,SIZE) RETURNS))
(AND SIZE-MACRO
(PUSH `(MACRO ,SIZE-MACRO (X) ,SIZE) RETURNS))
;Drops through.
;Drops in.
;Define the accessor macros.
(DO ((IL ITEMS (CDR IL))
(ITEM)
(N OFFSET (1+ N)))
((NULL IL)
(SETQ ITEM-LIST (REVERSE ITEM-LIST)
INIT-LIST (REVERSE INIT-LIST)))
(SETQ ITEM (CAR IL))
(COND ((SYMBOLP ITEM)
(PUSH ITEM ITEM-LIST)
(PUSH '*NOINIT* INIT-LIST)
(PUSH (DEFSTRUCT-MAKE-ACCESS-MACRO ITEM N NIL DEFAULT-POINTER
TYPE GROUPED-P)
RETURNS))
((SYMBOLP (CAR ITEM))
(PUSH (CAR ITEM) ITEM-LIST)
(PUSH (COND ((NULL (CDR ITEM)) '*NOINIT*)
(T (CADR ITEM)))
INIT-LIST)
(PUSH (DEFSTRUCT-MAKE-ACCESS-MACRO (CAR ITEM) N NIL DEFAULT-POINTER
TYPE GROUPED-P)
RETURNS))
(T
(DO ((L ITEM (CDR L))
(NAME)
(PPSS NIL NIL)
(INIT NIL NIL))
((NULL L))
(SETQ NAME (CAAR L))
(COND ((CDAR L)
(SETQ PPSS (CADAR L))
(SETQ INIT (COND ((CDDAR L) (CADDAR L))
(PPSS 0)))))
(PUSH NAME ITEM-LIST)
(PUSH INIT INIT-LIST)
(PUSH (DEFSTRUCT-MAKE-ACCESS-MACRO NAME N PPSS DEFAULT-POINTER
TYPE GROUPED-P)
RETURNS)))))
(COND (INCLUDE
(SETQ ITEM-LIST (APPEND (GET INCLUDE 'DEFSTRUCT-ITEMS) ITEM-LIST))
(SETQ INIT-LIST (APPEND (GET INCLUDE 'DEFSTRUCT-INITS) INIT-LIST))))
(DEFSTRUCT-PUTPROP NAME ITEM-LIST 'DEFSTRUCT-ITEMS)
(DEFSTRUCT-PUTPROP NAME INIT-LIST 'DEFSTRUCT-INITS)
;Drops through.
;Drops in.
;;; Creation of constructor macro.
(AND CONSTRUCTOR
(PUSH `(MACRO ,CONSTRUCTOR (X) ;Create a closure...
(DEFSTRUCT-GRAND-CONSTRUCTOR (CDR X)
',TYPE
',SIZE
',GROUPED-P
',NAMED-STRUCTURE
',ITEM-LIST
',INIT-LIST
',CONSTRUCTOR-ARRAY-OP
',CONSTRUCTOR-TIMES-OP))
RETURNS))
`(PROGN 'COMPILE .,RETURNS)))
;;; Creation of access macros.
;;; Make an access macro named NAME, which references a
;;; structure of TYPE type at element INDEX. If PPSS is not NIL then
;;; the macro made will also ldb that byte out. If DEFAULT-POINTER is not NIL
;;; then the generated macro will use that object as the operand if no operand is
;;; specified. If GROUPED-P is T then this
;;; should be a "grouped" access macro.
(DEFUN DEFSTRUCT-MAKE-ACCESS-MACRO (NAME INDEX PPSS DEFAULT-POINTER TYPE GROUPED-P)
`(DEFMACRO ,NAME
(,@(AND GROUPED-P '(I))
,@(COND (DEFAULT-POINTER `(&OPTIONAL (Z ',DEFAULT-POINTER)))
(T '(Z))))
,(LET ((TEM NIL))
(SETQ TEM (COND (GROUPED-P ``(+ ,I ,',INDEX))
(T `',INDEX)))
(SETQ TEM (SELECTQ TYPE
(ARRAY ``(AR-1 ,Z ,,TEM))
(ARRAY-LEADER ``(ARRAY-LEADER ,Z ,,TEM))
(LIST ``(NTH ,,TEM ,Z))))
(COND (PPSS ``(LDB ,',PPSS ,,TEM))
(T TEM)))))
(DEFUN DEFSTRUCT-GRAND-CONSTRUCTOR (ARGS TYPE SIZE GROUPED-P NAMED-STRUCTURE
ITEM-LIST INIT-LIST CONSTRUCTOR-ARRAY-OP
CONSTRUCTOR-TIMES-OP)
(LET ((ARGNAME NIL)
(MAKER NIL)
(GEN (GENSYM))
(GEN2 (GENSYM))
(WHOLESIZE NIL)
(INITED NIL)
(MAKE-ARRAY-ARG NIL))
(SETQ INIT-LIST (APPEND INIT-LIST NIL))
(DO ARGPAIR ARGS (CDDR ARGPAIR) (NULL ARGPAIR)
(SETQ ARGNAME (CAR ARGPAIR))
(SELECTQ ARGNAME
(MAKE-ARRAY (SETQ CONSTRUCTOR-ARRAY-OP (CADR ARGPAIR)))
(TIMES (SETQ CONSTRUCTOR-TIMES-OP (CADR ARGPAIR)))
(OTHERWISE
(DO ((ITEML ITEM-LIST (CDR ITEML))
(INITL INIT-LIST (CDR INITL)))
((NULL ITEML))
(COND ((EQ (CAR ITEML) ARGNAME)
(RPLACA INITL (CADR ARGPAIR))
(RETURN NIL)))))))
(COND ((EQ TYPE 'LIST)
`(LIST ,@INIT-LIST))
(T (SETQ WHOLESIZE (COND (GROUPED-P `(* ,SIZE ,CONSTRUCTOR-TIMES-OP))
(T SIZE))
MAKE-ARRAY-ARG (COND ((EQ TYPE 'ARRAY)
(LIST 'NIL ''ART-Q (COND (GROUPED-P GEN2)
(T WHOLESIZE))
'NIL 'NIL 'NIL `',NAMED-STRUCTURE))
(T (LIST 'NIL ''ART-Q '0 'NIL
WHOLESIZE 'NIL `',NAMED-STRUCTURE))))
;; Merge the user-specified MAKE-ARRAY option with the facts
;; that we have figured out.
(DO ((MAA MAKE-ARRAY-ARG (CDR MAA))
(CAO CONSTRUCTOR-ARRAY-OP (CDR CAO))
(FOO (COND ((EQ TYPE 'ARRAY)
'(T T NIL T T T NIL))
(T '(T T T T NIL T NIL))) (CDR FOO)))
((OR (NULL MAA) (NULL CAO)))
(AND (CAR FOO)
(RPLACA MAA (CAR CAO))))
(SETQ MAKER `(MAKE-ARRAY . ,MAKE-ARRAY-ARG))
;; See whether we know the type of the array, and if so set up INITED
;; as a function to detect elements being initialized to what they already are.
;; Numeric arrays are already zeros, others are already NILs.
(COND ((EQ TYPE 'ARRAY-LEADER)
(SETQ INITED (FUNCTION NULL)))
(T
(LET ((FORM (CADR MAKE-ARRAY-ARG)))
(COND ((AND (LISTP FORM)
(EQ (CAR FORM) 'QUOTE))
(SETQ FORM (CADR FORM))))
(LET ((X (ASSQ FORM ARRAY-BITS-PER-ELEMENT)))
(SETQ INITED
(COND ((NULL X) (FUNCTION FALSE))
((NULL (CDR X)) (FUNCTION NULL))
(T (FUNCTION ZEROP))))))))
(DO ((ITEML ITEM-LIST (CDR ITEML))
(INITL INIT-LIST (CDR INITL))
(GEN1 (GENSYM))
(CODE (COND ((NOT NAMED-STRUCTURE) NIL)
((EQ TYPE 'ARRAY)
`((AS-1 ',NAMED-STRUCTURE ,GEN 0)))
(T
`((STORE-ARRAY-LEADER ',NAMED-STRUCTURE ,GEN 1))))))
((NULL ITEML)
(COND (GROUPED-P
`(LET ((,GEN2 (* ,SIZE ,CONSTRUCTOR-TIMES-OP)))
(DO ((,GEN1 0 (+ ,GEN1 ,SIZE))
(,GEN ,MAKER))
((= ,GEN1 ,GEN2)
,GEN)
. ,CODE)))
(T
`(LET ((,GEN ,MAKER))
,@CODE
,GEN))))
-------
(OR (EQ (CAR INITL) '*NOINIT*)
(FUNCALL INITED (CAR INITL))
(PUSH `(SETF (,(CAR ITEML)
,@(AND GROUPED-P (NCONS GEN1))
,GEN)
,(CAR INITL))
CODE)))))))
;; Property names used herein are:
;; DEFSTRUCT-TYPE
;; DEFSTRUCT-NAMED-P
;; DEFSTRUCT-GROUPED-P
;; DEFSTRUCT-SIZE
;; DEFSTRUCT-ITEMS
;; DEFSTRUCT-INITS
;(SETF (element pntr) value)
(DEFUN SETF MACRO (X) (SETF-1 X))
(DEFUN SETF-1 (X)
(PROG (FCN REF VAL)
(SETQ REF (CADR X))
(SETQ VAL (CADDR X))
LOOP
(RETURN (COND ((SYMBOLP REF) ;SPECIAL CASE NEEDED.
(LIST 'SETQ REF VAL))
((NULL (SETQ FCN (GET (CAR REF) 'SETF))) ;FIND INVERSION FUNCTION
(OR (EQ REF (SETQ REF (MACROEXPAND-1 REF T))) ;NONE => TRY EXPANDING MACRO.
(GO LOOP))
(ERROR "No SETF property found, can't invert this reference" X))
((SYMBOLP FCN)
(FUNCALL FCN REF VAL))
(T (DO ((PATTERN (CDAR FCN) (CDR PATTERN))
(REF (CDR REF) (CDR REF))
(SUBS (LIST (CONS 'VAL VAL))
(CONS (CONS (CAR PATTERN) (CAR REF)) SUBS)))
((OR (NULL PATTERN) (NULL REF))
(AND (OR PATTERN REF)
(ERROR "Reference not same length as pattern - SETF" X))
(SUBLIS SUBS (CDR FCN)))))))))
;(LOCF (element pntr))
;Constructs a form which returns a locative pointer to the "referenced" element
;of the structure.
(DEFUN LOCF MACRO (X) (LOCF-1 X))
(DEFUN LOCF-1 (X)
(PROG (FCN REF)
(SETQ REF (CADR X))
LOOP
(RETURN (COND ((SYMBOLP REF) ;SPECIAL CASE NEEDED.
(LIST 'VALUE-CELL-LOCATION REF))
((NULL (SETQ FCN (GET (CAR REF) 'LOCF)))
(OR (EQ REF (SETQ REF (MACROEXPAND-1 REF T)))
(GO LOOP))
(ERROR "No LOCF property found, can't work." X))
((SYMBOLP FCN)
(FUNCALL FCN REF))
(T (DO ((PATTERN (CDAR FCN) (CDR PATTERN))
(REF (CDR REF) (CDR REF))
(SUBS NIL (CONS (CONS (CAR PATTERN) (CAR REF)) SUBS)))
((OR (NULL PATTERN) (NULL REF))
(AND (OR PATTERN REF)
(ERROR "Reference not same length as pattern - LOCF" X))
(SUBLIS SUBS (CDR FCN)))))))))
;(GET-LIST-POINTER-INTO-STRUCT (element pntr))
(DEFUN GET-LIST-POINTER-INTO-STRUCT MACRO (X)
(PROG (REF)
(SETQ REF (MACROEXPAND (CADR X) T)) ;EXPAND MACROS LOOKING AT BAG-BITING MACRO LIST
(COND ((EQ (CAR REF) 'AR-1)
(RETURN (LIST 'GET-LIST-POINTER-INTO-ARRAY
(LIST 'FUNCALL (CADR REF) (CADDR REF)))))
((ERROR "LOSES - GET-LIST-POINTER-INTO-STRUCT" X)))))
;Load time defprops for SETF and LOCF.
;Value of the SETF property is either an symbol which is a function
; which is applied to two arguments: the reference and the value
; to be stored into it, or it is CONS of a 1-level pattern to
; match against REF and a form in which substitutions
; are made for the symbol VAL and the pattern atoms.
;The value of the LOCF property is very similar; if it is
;a symbol then it is a function to be applied to one argument,
;the reference. Otherwise it is a pattern as in SETF, except
;that the symbol VAL is not special.
(DEFPROP AR-1 ((AR-1 ARRAY INDEX)
AS-1 VAL ARRAY INDEX) SETF)
(DEFPROP AR-1 ((AR-1 ARRAY INDEX)
AP-1 ARRAY INDEX) LOCF)
(DEFPROP AR-2 ((AR-2 ARRAY INDEX1 INDEX2)
AS-2 VAL ARRAY INDEX1 INDEX2) SETF)
(DEFPROP AR-2 ((AR-2 ARRAY INDEX1 INDEX2)
AP-2 ARRAY INDEX1 INDEX2) LOCF)
(DEFPROP AR-3 ((AR-3 ARRAY INDEX1 INDEX2 INDEX3)
AS-3 VAL ARRAY INDEX1 INDEX2 INDEX3) SETF)
(DEFPROP AR-3 ((AR-3 ARRAY INDEX1 INDEX2 INDEX3)
AP-3 ARRAY INDEX1 INDEX2 INDEX3) LOCF)
(DEFPROP ARRAY-LEADER ((ARRAY-LEADER ARRAY INDEX)
STORE-ARRAY-LEADER VAL ARRAY INDEX) SETF)
(DEFPROP ARRAY-LEADER ((ARRAY-LEADER ARRAY INDEX)
AP-LEADER ARRAY INDEX) LOCF)
(DEFPROP CDR ((CDR ITEM)
RPLACD ITEM VAL) SETF)
(DEFPROP CDDR ((CDDR ITEM)
RPLACD (CDR ITEM) VAL) SETF)
(DEFPROP CDDDR ((CDDDR ITEM)
RPLACD (CDDR ITEM) VAL) SETF)
(DEFPROP CDDDDR ((CDDDDR ITEM)
RPLACD (CDDDR ITEM) VAL) SETF)
(DEFPROP CDDDAR ((CDDDAR ITEM)
RPLACD (CDDAR ITEM) VAL) SETF)
(DEFPROP CDDAR ((CDDAR ITEM)
RPLACD (CDAR ITEM) VAL) SETF)
(DEFPROP CDDADR ((CDDADR ITEM)
RPLACD (CDADR ITEM) VAL) SETF)
(DEFPROP CDDAAR ((CDDAAR ITEM)
RPLACD (CDAAR ITEM) VAL) SETF)
(DEFPROP CDAR ((CDAR ITEM)
RPLACD (CAR ITEM) VAL) SETF)
(DEFPROP CDADR ((CDADR ITEM)
RPLACD (CADR ITEM) VAL) SETF)
(DEFPROP CDADDR ((CDADDR ITEM)
RPLACD (CADDR ITEM) VAL) SETF)
(DEFPROP CDADAR ((CDADAR ITEM)
RPLACD (CADAR ITEM) VAL) SETF)
(DEFPROP CDAADR ((CDAADR ITEM)
RPLACD (CAADR ITEM) VAL) SETF)
(DEFPROP CDAAAR ((CDAAAR ITEM)
RPLACD (CAAAR ITEM) VAL) SETF)
(DEFPROP CAR ((CAR ITEM)
RPLACA ITEM VAL) SETF)
(DEFPROP CADR ((CADR ITEM)
RPLACA (CDR ITEM) VAL) SETF)
(DEFPROP CADDR ((CADDR ITEM)
RPLACA (CDDR ITEM) VAL) SETF)
(DEFPROP CADDDR ((CADDDR ITEM)
RPLACA (CDDDR ITEM) VAL) SETF)
(DEFPROP CADDAR ((CADDAR ITEM)
RPLACA (CDDAR ITEM) VAL) SETF)
(DEFPROP CADAR ((CADAR ITEM)
RPLACA (CDAR ITEM) VAL) SETF)
(DEFPROP CADADR ((CADADR ITEM)
RPLACA (CDADR ITEM) VAL) SETF)
(DEFPROP CADAAR ((CADAAR ITEM)
RPLACA (CDAAR ITEM) VAL) SETF)
(DEFPROP CAAR ((CAAR ITEM)
RPLACA (CAR ITEM) VAL) SETF)
(DEFPROP CAADR ((CAADR ITEM)
RPLACA (CADR ITEM) VAL) SETF)
(DEFPROP CAADDR ((CAADDR ITEM)
RPLACA (CADDR ITEM) VAL) SETF)
(DEFPROP CAADAR ((CAADAR ITEM)
RPLACA (CADAR ITEM) VAL) SETF)
(DEFPROP CAAADR ((CAAADR ITEM)
RPLACA (CAADR ITEM) VAL) SETF)
(DEFPROP CAAAAR ((CAAAAR ITEM)
RPLACA (CAAAR ITEM) VAL) SETF)
(DEFPROP FSYMEVAL ((FSYMEVAL ITEM)
FSET ITEM VAL) SETF)
(DEFPROP FSYMEVAL ((FSYMEVAL ITEM)
FUNCTION-CELL-LOCATION ITEM) LOCF)
(DEFPROP LDB ((LDB PPSS REF)
SETF REF (DPB VAL PPSS REF)) SETF)
(DEFPROP GET ((GET ATOM PROP)
PUTPROP ATOM VAL PROP) SETF)
(DEFPROP NTH ((NTH N LIST)
RPLACA (NTHCDR N LIST) VAL) SETF)
(DEFPROP ARG ((ARG N)
SETARG N VAL) SETF)